perm filename FORS[1,LMM]1 blob
sn#029053 filedate 1973-03-09 generic text, type T, neo UTF8
00100 (DE MAKEMAKECOPY (X)
00200 (COND ((MEMQ (CAR X)
00300 (QUOTE (APPEND LIST COPY)))
00400 X)
00500 (T (LIST (QUOTE APPEND)
00600 X))))
00700 (DE REMOVEIS (FORM)
00800 (COND ((NULL FORM)
00900 NIL)
01000 ((EQ (CAR FORM)
01100 (QUOTE IS))
01200 (REMOVEIS (CDR FORM)))
01300 ((EQ (CAR FORM)
01400 (QUOTE =))
01500 (REMOVEIS (CDR FORM)))
01600 (T (CONS (CAR FORM)
01700 (REMOVEIS (CDR FORM))))))
01800 (DE RECORD (NAME FIELD)
01900 (PROG NIL (PUTPROP NAME FIELD (QUOTE RECORD))
02000 (PUTPROP NAME (LIST (QUOTE LAMBDA)
02100 (QUOTE (RECORDVAR))
02200 (LIST (QUOTE COMPOSE)
02300 (QUOTE (REMOVEIS RECORDVAR))
02400 (LIST (QUOTE QUOTE)
02500 FIELD)))
02600 (QUOTE MACRO))
02700 (RECDO FIELD (QUOTE X))))
02800 (DE
02900 RECDO
03000 (FORMAT DEF)
03100 (COND
03200 ((NULL FORMAT)
03300 NIL)
03400 ((NOT (ATOM FORMAT))
03500 (RECDO (CAR FORMAT)
03600 (LIST (QUOTE CAR)
03700 DEF))
03800 (RECDO (CDR FORMAT)
03900 (LIST (QUOTE CDR)
04000 DEF)))
04100 (T (PUTPROP FORMAT
04200 (LIST (QUOTE LAMBDA)
04300 (QUOTE (RECORDFIELDVAR))
04400 (LIST (QUOTE SUBST)
04500 (QUOTE (COND
04600 ((NULL (CDDR (SETQ
04700 RECORDFIELDVAR
04800 (REMOVEOF
04900
05000 RECORDFIELDVAR))))
05100 (CADR RECORDFIELDVAR))
05200 (T RECORDFIELDVAR)))
05300 (QUOTE (QUOTE X))
05400 (LIST (QUOTE QUOTE)
05500 DEF)))
05600 (QUOTE MACRO)))))
05700 (DE REMOVEOF (L)
05800 (COND ((NULL L)
05900 NIL)
06000 ((EQ (CAR L)
06100 (QUOTE OF))
06200 (REMOVEOF (CDR L)))
06300 (T (CONS (CAR L)
06400 (REMOVEOF (CDR L))))))
06500 (DE COMPOSE (L FIELD)
06600 (COND ((EQ (CAR L)
06700 (QUOTE FROM))
06800 (COND ((ATOM (CADR L))
06900 (COMPOSE1 L FIELD (CADR L)))
07000 (T (LIST (LIST (QUOTE LAMBDA)
07100 (QUOTE (COMPOSEVAR))
07200 (COMPOSE1 L FIELD (QUOTE COMPOSEVAR)))
07300 (CADR L)))))
07400 (T (COMPOSE1 L FIELD (QUOTE COMPOSEVAR)))))
07500 (DE COMPOSE1 (L FIELD DEF)
07600 (PROG (K)
07650 (RETURN
07700 (COND ((SETQ K (COMPOSE2 L FIELD DEF))
07800 (CAR K))
07900 (T (COMPOSE3 L FIELD DEF))))))
08000 (DE
08100 COMPOSE2
08200 (L FIELD DEF)
08300 (COND
08400 ((NULL FIELD)
08500 NIL)
08600 ((ATOM FIELD)
08700 (COND ((MEMQ FIELD L)
08800 (LIST (SUBST DEF (QUOTE **)
08900 (GET1 L FIELD))))
09000 (T NIL)))
09100 ((EQ (CAR FIELD)
09200 (QUOTE ID))
09300 (LIST (LIST (QUOTE QUOTE)
09400 (CDR FIELD))))
09500 (T
09600 (PROG (KA KD)
09700 (SETQ KD (COMPOSE2 L (CDR FIELD)
09800 (LIST (QUOTE CDR)
09900 DEF)))
10000 (SETQ KA (COMPOSE2 L (CAR FIELD)
10100 (LIST (QUOTE CAR)
10200 DEF)))
10300 (COND ((AND (NULL KA)
10400 (NULL KD))
10500 (RETURN NIL)))
10600 (RETURN
10700 (LIST (#CONS (COND (KA (CAR KA))
10800 (T (COMPOSE1 L (CAR FIELD)
10900 (LIST (QUOTE CAR)
11000 DEF))))
11100 (COND (KD (CAR KD))
11200 (T (COMPOSE1 L (CDR FIELD)
11300 (LIST (QUOTE CDR)
11400 DEF)))))))))))
11500 (DE COMPOSE3 (L FIELD DEF)
11600 (COND ((EQ (QUOTE FROM)
11700 (CAR L))
11800 DEF)
11900 (T (COMPOSE4 FIELD))))
12000 (DE COMPOSE4 (FIELD)
12100 (COND ((NULL FIELD)
12200 NIL)
12300 ((ATOM FIELD)
12400 ((LAMBDA (X)
12500 (COND (X (LIST (QUOTE QUOTE)
12600 X))
12700 (T NIL)))
12800 (GET FIELD (QUOTE RECDEFAULT))))
12900 (T (#CONS (COMPOSE4 (CAR FIELD))
13000 (COMPOSE4 (CDR FIELD))))))
13100 (DE #CONS (CARPART CDRPART)
13200 (COND ((NOT CDRPART)(LIST(QUOTE LIST)CARPART))
13300 ((EQ(CAR CDRPART)(QUOTE LIST))
13400
13500 (CONS (QUOTE LIST)
13600 (CONS CARPART (CDR CDRPART))))
13700 (T (LIST (QUOTE CONS)
13800 CARPART CDRPART))))
13900 (DE #REPLACE (CARPART CDRPART)
14000 (COND ((NULL CARPARP)
14100 CDRPART)
14200 ((NULL CDRPART)
14300 CARPART)
14400 ((AND (EQ (CAR CARPART)
14500 (QUOTE RPLACA))
14600 (EQ (CAR CDRPART)
14700 (QUOTE RPLACD))
14800 (EQUAL (CADR CARPART)
14900 (CADR CDRPART)))
15000 (LIST (QUOTE RPLACD)
15100 CARPART
15200 (CADDR CDRPART)))
15300 (T (LIST (QUOTE PROG2)
15400 CARPART CDRPART))))
15500 (DE
15600 *FOR
15700 (L)
15800 (PROG
15900 (N FV PV EPILOGUE PROLOGUE DOFORM DOTYPE VAR RANGE LST VARNEXT
16000 NEXT NEXTS N2 N3 INIT TESTSET)
16100 (SETQ N 1)
16200 FORLOOP
16300 (COND ((EQ (CAR L)
16400 (QUOTE NEW))
16500 (+PV (CAR (SETQ L (CDR L))))))
16600 (SETQ VAR (CAR L))
16700 (SETQ RANGE (CADDR L))
16800 (+NEXT (SETQ VARNEXT (VARNAME (QUOTE NEXT))))
16900 (COND
17000 ((EQ (CADR L)
17100 (QUOTE IN))
17200 (+TESTSET (CONDIT (NEGATE (INITL (+PV (SETQ
17300 LST
17400 (VARNAME (QUOTE LIST)))
17500 )
17600 RANGE))
17700 (GONEXTN)))
17800 (+TESTSET (SETIT VAR (LIST (QUOTE CAR)
17900 LST)))
18000 (+NEXT (SETIT LST (LIST (QUOTE CDR)
18100 LST))))
18200 ((EQ (CADR L)
18300 (QUOTE ON))
18400 (+TESTSET (CONDIT (NEGATE VAR)
18500 (GONEXTN)))
18600 (+NEXT (SETIT (INITL VAR RANGE)
18700 (LIST (QUOTE CDR)
18800 VAR))))
18900 ((EQ (CADR L)
19000 (QUOTE :=))
19100 (SETQ N2 (COND ((ATOM (CADR RANGE))
19200 (CADR RANGE))
19300 (T (INITL (+PV (VARNAME (QUOTE MAX)))
19400 (CADR RANGE)))))
19500 (SETQ N3 (COND ((CDDR RANGE)
19600 (COND
19700 ((ATOM (CADDR RANGE))
19800 (CADDR RANGE))
19900 (T (INITL (+PV (VARNAME (QUOTE INC)))
20000 (CADDR RANGE)))))
20100 ((AND (NUMBERP (CAR RANGE))
20200 (NUMBERP (CADR RANGE))
20300 (GREATERP (CAR RANGE)
20400 (CADR RANGE)))
20500 -1)
20600 (T 1)))
20700 (INITL VAR (CAR RANGE))
20800 (+TESTSET (CONDIT
20900 (COND ((NOT (NUMBERP N3))
21000 (LIST (QUOTE COND)
21100 (LIST (LIST (QUOTE MINUSP)
21200 N3)
21300 (LIST (QUOTE LESSP)
21400 VAR N2))
21500 (LIST T (LIST (QUOTE OR)
21600 (LIST (QUOTE ZEROP)
21700 N3)
21800 (LIST (QUOTE GREATERP)
21900 VAR N2)))))
22000 ((MINUSP N3)
22100 (LIST (QUOTE LESSP)
22200 VAR N2))
22300 (T (LIST (QUOTE GREATERP)
22400 VAR N2)))
22500 (GONEXTN)))
22600 (+NEXT (SETIT VAR (LIST (QUOTE PLUS)
22700 VAR N3))))
22800 ((EQ (CADR L)
22900 (QUOTE IS))
23000 (+TESTSET (SETIT VAR RANGE)))
23100 (T (ERROR "INVALID FOR TYPE")))
23200 (SETQ L (CDDDR L))
23300 ASLOOP
23400 (COND ((EQ (CAR L)
23500 (QUOTE AS))
23600 (SETQ L (CDR L))
23700 (SETQ NEXTS (APPEND NEXTS NEXT))
23800 (SETQ NEXT NIL)
23900 (GO FORLOOP))
24000 ((MEMQ (CAR L)
24100 (QUOTE (IF WHEN)))
24200 (+TESTSET (CONDIT (NEGATE (CADR L))
24300 (LIST (QUOTE GO)
24400 VARNEXT)))
24500 (SETQ L (CDDR L)))
24600 ((EQ (CAR L)
24700 (QUOTE UNTIL))
24800 (+NEXT (CONDIT (CADR L)
24900 (GONEXTN)))
25000 (SETQ L (CDDR L)))
25100 ((EQ (CAR L)
25200 (QUOTE WHILE))
25300 (+TESTSET (CONDIT (NEGATE (CADR L))
25400 (GONEXTN)))
25500 (SETQ L (CDDR L)))
25600 (T (GO FORTEST)))
25700 (GO ASLOOP)
25800 FORTEST
25900 (SETQ PROLOGUE (APPEND TESTSET (LIST (| (QUOTE LOOP)
26000 N))
26100 INIT PROLOGUE))
26200 (SETQ EPILOGUE (CONS (| (QUOTE NEXT)
26300 N)
26400 (APPEND (REVERSE NEXT)
26500 (REVERSE NEXTS)
26600 (CONS (LIST (QUOTE GO)
26700 (| (QUOTE LOOP)
26800 N))
26900 EPILOGUE))))
27000 (SETQ TESTSET (SETQ INIT (SETQ NEXT (SETQ NEXTS NIL))))
27100 (COND ((EQ (CAR L)
27200 (QUOTE FOR))
27300 (SETQ L (CDR L))
27400 (SETQ N (ADD1 N))
27500 (GO FORLOOP)))
27600 (SETQ DOTYPE (CAR L))
27700 (SETQ DOVAL (CAR (LAST L)))
27800 (+PV (QUOTE FOR-VALUE))
27900 (SETQ FV (QUOTE FOR-VALUE))
28000 (SETQ DOFORM (COND ((MEMQ DOTYPE (QUOTE (AND OR)))
28100 (CONDIT (LIST (COND ((EQ DOTYPE (QUOTE AND))
28200 (INITL (QUOTE FOR-VALUE)
28300 T)
28400 (QUOTE NOT))
28500 (T (QUOTE PROG2)))
28600 (SETIT (QUOTE FOR-VALUE)
28700 DOVAL))
28800 (QUOTE (RETURN FOR-VALUE))))
28900 ((MEMQ DOTYPE (QUOTE (PROGN PROG2)))
29000 (SETIT (QUOTE FOR-VALUE)
29100 DOVAL))
29200 ((EQ DOTYPE (QUOTE DO))
29300 DOVAL)
29400 (T (SETIT (QUOTE FOR-VALUE)
29500 (COND ((EQ DOTYPE (QUOTE LIST))
29600 (LIST (QUOTE NCONC)
29700 (QUOTE FOR-VALUE)
29800 (LIST (QUOTE LIST)
29900 DOVAL)))
30000 ((EQ DOTYPE (QUOTE NCONC))
30100 (LIST (QUOTE NCONC)
30200 (QUOTE FOR-VALUE)
30300 DOVAL))
30400 ((EQ DOTYPE (QUOTE XLIST))
30500 (LIST (QUOTE CONS)
30600 DOVAL
30700 (QUOTE FOR-VALUE)))
30800 ((EQ DOTYPE (QUOTE APPEND))
30900 (LIST (QUOTE NCONC)
31000 (QUOTE FOR-VALUE)
31100 (MAKEMAKECOPY DOVAL)))
31200 (T (LIST DOTYPE DOVAL
31300 (QUOTE FOR-VALUE))))))
31400 ))
31500 (COND ((EQ (CAR (SETQ L (CDR L)))
31600 (QUOTE FIRST))
31700 (INITL (QUOTE FOR-VALUE)
31800 (CADR L))
31900 (SETQ L (CDDR L)))
32000 ((MEMQ DOTYPE (QUOTE (PLUS IPLUS TIMES ITIMES MAX MIN)))
32100 (INITL (QUOTE FOR-VALUE)
32200 (CDR (ASSOC DOTYPE (QUOTE ((PLUS . 0)
32300 (MAX . -99999)
32400 (MIN . 99999)
32500 (IPLUS . 0)
32600 (TIMES . 1)
32700 (ITIMES . 1))))))))
32800 (RETURN (CONS (QUOTE PROG)
32900 (CONS PV (APPEND INIT (REVERSE PROLOGUE)
33000 (REVERSE (CDR (REVERSE L)))
33100 (LIST DOFORM)
33200 EPILOGUE
33300 (LIST (QUOTE RETURN)
33400 (LIST (QUOTE RETURN)
33500 FV))))))))
33600 (DE +NEXT (ITEM)
33700 (PROG2 (SETQ NEXT (CONS ITEM NEXT))
33800 ITEM))
33900 (DE CONDIT (PRD DO)
34000 (LIST (QUOTE COND)
34100 (LIST PRD DO)))
34200 (DE SETIT (VAR VAL)
34300 (COND ((NOT (EQ VAR VAL))
34400 (LIST (QUOTE SETQ)
34500 VAR VAL))
34600 (T NIL)))
34700 (DE INITL (VAR VAL)
34800 (PROG2 (SETQ INIT (CONS (SETIT VAR VAL)
34900 INIT))
35000 VAR))
35100 (DE +PV (VAR)
35200 (PROG2 (SETQ PV (CONS VAR PV))
35300 VAR))
35400 (DE +TESTSET (ITEM)
35500 (PROG2 (SETQ TESTSET (CONS ITEM TESTSET))
35600 ITEM))
35700 (DE NEGATE (EXP)
35800 (COND ((MEMQ (CAR EXP)
35900 (QUOTE (NOT NULL)))
36000 (CADR EXP))
36100 (T (LIST (QUOTE NOT)
36200 EXP))))
36300 (DE *IF (L)
36400 (COND (L (CONS (CONS (CAR L)
36500 (COND ((NOT (EQ (CADR L)
36600 (QUOTE THEN)))
36700 (ERROR L
36800 "NO CORRESPONDING THEN IN IF"))
36900 (T (SETQ L (CDDR L))
37000 (THENCLAUSE))))
37100 (COND ((NULL L)
37200 NIL)
37300 ((EQ (CAR L)
37400 (QUOTE ELSEIF))
37500 (*IF (CDR L)))
37600 ((EQ (CAR (SETQ L (CDR L)))
37700 (QUOTE IF))
37800 (*IF (CDR L)))
37900 (T (LIST (CONS T (THENCLAUSE)))))))
38000 (T NIL)))
38100 (DE THENCLAUSE NIL (COND ((OR (NULL L)
38200 (MEMQ (CAR L)
38300 (QUOTE (ELSE ELSEIF))))
38400 (LIST NIL))
38500 ((OR (NOT (CDR L))
38600 (MEMQ (CADR L)
38700 (QUOTE (ELSE ELSEIF))))
38800 ((LAMBDA (X Y)
38900 X)
39000 (LIST (CAR L))
39100 (SETQ L (CDR L))))
39200 (T (CONS (CAR L)
39300 (PROG2 (SETQ L (CDR L))
39400 (THENCLAUSE))))))
39500 (DE QUOTEIT1 (X M)
39600 (COND ((OR (NULL X)
39700 (NUMBERP X)
39800 (EQ X T))
39900 X)
40000 ((SETQ M (QUOTEIT2 X M))
40100 M)
40200 (T (LIST (QUOTE QUOTE)
40300 X))))
40400 (DE
40500 QUOTEIT2
40600 (X N)
40700 (COND
40800 ((ATOM X)
40900 NIL)
41000 ((EQ (CAR X)
41100 (QUOTE ¬))
41200 (COND ((ATOM (CDR X))
41300 (CDR X))
41400 ((NULL (CDDR X))
41500 (LIST (QUOTE LIST)
41600 (CADR X)))
41700 (T ((LAMBDA (D E)
41800 (COND ((EQ (CAR D)
41900 (QUOTE LIST))
42000 (CONS (QUOTE LIST)
42100 (CONS E (CDR D))))
42200 (T (LIST (QUOTE CONS)
42300 E D))))
42400 (QUOTEIT1 (CDDR X))
42500 (CADR X)))))
42600 ((NULL (CDR X))
42700 (COND ((SETQ N (QUOTEIT2 (CAR X)
42800 N))
42900 (LIST (QUOTE LIST)
43000 N))
43100 (T NIL)))
43200 (T (PROG (M)
43300 (SETQ M (QUOTEIT2 (CAR X)
43400 N))
43500 (SETQ N (QUOTEIT2 (CDR X)
43600 N))
43700 (COND ((AND (NULL M)
43800 (NULL N))
43900 (RETURN NIL)))
44000 (COND ((AND (NULL M)
44100 (SETQ M (CAR X))
44200 (NOT (NUMBERP M))
44300 (NOT (EQ M T)))
44400 (SETQ M (LIST (QUOTE QUOTE)
44500 M))))
44600 (RETURN (COND
44700 ((EQ (CAR N)
44800 (QUOTE LIST))
44900 (CONS (CAR N)
45000 (CONS M (CDR N))))
45100 (T (LIST (QUOTE CONS)
45200 M
45300 (COND ((AND (NULL N)
45400 (SETQ N (CDR X))
45500 (NOT (NUMBERP N))
45600 (NOT (EQ N T)))
45700 (LIST (QUOTE QUOTE)
45800 N))
45900 (T N))))))))))
46000 (DE VARNAME (STR)
46100 (| STR VAR))
46200 (DE GONEXTN NIL (LIST (QUOTE GO)
46300 (COND ((EQUAL N 1)
46400 (QUOTE RETURN))
46500 (T (| (QUOTE NEXT)
46600 (SUB1 N))))))
46700 (DE | (STR VAL)
46800 (READLIST (NCONC (EXPLODE STR)
46900 (CONS (QUOTE *)
47000 (EXPLODE VAL)))))
47100 (DM FOR (FOR-EXPRESSION)
47200 (*FOR (CDR FOR-EXPRESSION)))
47300 (DM IF (IF-EXPRESSION)
47400 (CONS (QUOTE COND)
47500 (*IF (CDR IF-EXPRESSION))))
47600 (DM REPLACE (REPLACEXP)
47700 (PROG (REPLACE1 REPLACE2)
47800 (SETQ REPLACE1 (FULLEXPANSION (CADR REPLACEXP)))
47900 (SETQ REPLACE2 (CADDR REPLACEXP))
48000 (RETURN (LIST (COND ((EQ (CAR REPLACE1)
48100 (QUOTE CAR))
48200 (QUOTE RPLACA))
48300 ((EQ (CAR REPLACE1)
48400 (QUOTE CDR))
48500 (QUOTE RPLACD))
48600 (HELP "REPLACE CAN'T" (LIST REPLACE1
48700 REPLACE2)))
48800 (CADR REPLACE1)
48900 REPLACE2))))
49000 (DE FULLEXPANSION (EXPR)
49100 (COND ((MEMQ (CAR X)
49200 (QUOTE (CAAR CADR CDAR CDDR CDDAR CDDDR CDDDAR
49300 CDDDDR CADDAR CADDDR CADAR CADDR CDADAR
49400 CDADDR CAADAR CAADDR CDAAR CDADR CDDAAR
49500 CDDADR CADAAR CADADR CAAAR CAADR CDAAAR
49600 CDAADR CAAAAR CAAADR)))
49700 (LIST (READLIST (LIST (QUOTE C)
49800 (CADR (EXPLODE (CAR X)))
49900 (QUOTE R)))
50000 (LIST (READLIST (CONS (QUOTE C)
50100 (CDDR (EXPLODE (CAR X)))))
50200 (CADR X))))
50300 ((GET (CAR X)
50400 (QUOTE MACRO))
50500 (FULLEXPANSION (APPLY (GET (CAR X)
50600 (QUOTE MACRO))
50700 (LIST X))))
50800 (T X)))
50900 STOP